home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / DBASE_UT / TPDB335 / TPDBSORT.PAS < prev    next >
Pascal/Delphi Source File  |  1993-11-26  |  4KB  |  158 lines
  1. unit TPDBSORT;
  2.  
  3.                            (***********************************)
  4.                            (*               TPDB              *)
  5.                            (***********************************)
  6.                            (*         Object -Oriented        *)
  7.                            (*    Borland/Turbo Pascal Units   *)
  8.                            (*    for Accessing dBASE III      *)
  9.                            (*             files.              *)
  10.                            (*      Copyright 1988 - 1993      *)
  11.                            (*          Brian Corll            *)
  12.                            (*       All Rights Reserved       *)
  13.                            (***********************************)
  14.                            (*            FREEWARE             *)
  15.                            (***********************************)
  16.                            (*     dBASE is a registered       *)
  17.                            (* trademark of Borland Int. Inc.  *)
  18.                            (*   Version 3.35  November, 1993  *)
  19.                            (***********************************)
  20.                            (*   Portions Copyright 1984,1991  *)
  21.                            (*    Borland International Corp.  *)
  22.                            (***********************************)
  23. interface
  24.  
  25. uses
  26.     Crt, TPDB, TPDBSrtS, TPDBSrtL, TPDBStr;
  27.  
  28. const
  29.     OneA : Byte = $1A;
  30. type
  31.     SortingFunction = function: DBKey;
  32.     ProcPtr = ^byte;
  33.  
  34. var
  35. SortFile : DataObject;
  36. SortFunc : SortingFunction;
  37.  
  38. PROCEDURE SortOn(Operation : SortingFunction;Source,Dest : FileName);
  39.  
  40. IMPLEMENTATION
  41.  
  42. CONST
  43. EOFMarker : Char = #26;
  44.  
  45. TYPE
  46. SortRecord = RECORD
  47. KeyStr : DBKey;
  48. RecNum : LONGINT;
  49. END;
  50.  
  51. VAR
  52. SortRec : SortRecord;
  53. OutFile : File;
  54. SortResult,LSortResult : Integer;
  55. SortFileName : FileName;
  56.  
  57.  
  58. {$F+}
  59.  
  60.  
  61. PROCEDURE ReadRecs;
  62. VAR
  63. RecNum : LONGINT;
  64. BEGIN
  65. RecNum := 1;
  66. FOR RecNum := 1 TO SortFile^.TotalRecs do
  67. BEGIN
  68. SortFile^.GetDBRec(RecNum);
  69. SortRec.KeyStr := SortFunc;
  70. SortRec.RecNum := RecNum;
  71. SortRelease(SortRec);
  72. END;
  73. END;
  74.  
  75. FUNCTION LessRecs(VAR x,y : SortRecord) : BOOLEAN;
  76. BEGIN
  77. LessRecs := x.KeyStr < y.KeyStr;
  78. END;
  79.  
  80. PROCEDURE WriteRecs;
  81. VAR
  82. X : LONGINT;
  83. FNo : BYTE;
  84. BEGIN
  85. Assign(OutFile,SortFileName);
  86. ReWrite(OutFile,1);
  87. BlockWrite(OutFile,SortFile^.Header^,32,ErrCode);
  88. For FNo := 1 to SortFile^.NumFields do
  89. BlockWrite(OutFile,SortFile^.Fields^[FNo],32,ErrCode);
  90. SortFile^.Header^.Terminator := Chr(Ord($0D));
  91. BlockWrite(OutFile,SortFile^.Header^.Terminator,1,ErrCode);
  92. X := 1;
  93. REPEAT
  94. SortReturn(SortRec);
  95. SortFile^.GetDBRec(SortRec.RecNum);
  96. BlockWrite(OutFile,Mem[Seg(SortFile^.DBRecord^):Ofs(SortFile^.DBRecord^)],SortFile^.Header^.RecordLen);
  97. UNTIL SortEOS;
  98. Close(OutFile);
  99. END;
  100.  
  101. PROCEDURE LReadRecs;
  102. VAR
  103. RecNum : LONGINT;
  104. BEGIN
  105. RecNum := 1;
  106. REPEAT
  107. SortFile^.GetDBRec(RecNum);
  108. SortRec.KeyStr := SortFunc;
  109. SortRec.RecNum := RecNum;
  110. SortRelease(SortRec);
  111. INC(RecNum);
  112. UNTIL SortFile^.DBEOF;
  113. END;
  114.  
  115. FUNCTION LLessRecs(VAR x,y : SortRecord) : BOOLEAN;
  116. BEGIN
  117. LLessRecs := x.KeyStr < y.KeyStr;
  118. END;
  119.  
  120. PROCEDURE LWriteRecs;
  121. VAR
  122. X : LONGINT;
  123.  
  124. FNo : BYTE;
  125. BEGIN
  126. Assign(OutFile,SortFileName);
  127. ReWrite(OutFile,1);
  128. BlockWrite(OutFile,SortFile^.Header^,32,ErrCode);
  129. For FNo := 1 to SortFile^.NumFields do
  130. BlockWrite(OutFile,SortFile^.Fields^[FNo],32,ErrCode);
  131. SortFile^.Header^.Terminator := Chr(Ord($0D));
  132. BlockWrite(OutFile,SortFile^.Header^.Terminator,1,ErrCode);
  133. BlockWrite(OutFile,OneA,1,ErrCode);
  134. X := 1;
  135. REPEAT
  136. SortReturn(SortRec);
  137. SortFile^.GetDBRec(SortRec.RecNum);
  138. BlockWrite(OutFile,Mem[Seg(SortFile^.DBRecord^):Ofs(SortFile^.DBRecord^)],SortFile^.Header^.RecordLen);
  139. UNTIL SortEOS;
  140. BlockWrite(OutFile,EOFMarker,1);
  141. Close(OutFile);
  142. END;
  143. {$F-}
  144.  
  145. PROCEDURE SortOn(Operation : SortingFunction;Source,Dest : FileName);
  146. BEGIN
  147. NEW(SortFile,Init(Source));
  148. SortFileName := Dest;
  149. IF SortFile^.TotalRecs <= 32767 THEN
  150. SortResult := SmallTPDBSort(SizeOf(SortRec),@ReadRecs,@LessRecs,@WriteRecs)
  151. ELSE
  152. LSortResult := LargeTPDBSort(SizeOf(SortRec),@LReadRecs,@LLessRecs,@LWriteRecs);
  153. DISPOSE(SortFile,Done);
  154. END;
  155.  
  156. BEGIN
  157. END.
  158.